home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
Open Prolog 1.0.3d33
/
External Predicates…
/
Sources
/
draw.p
< prev
next >
Wrap
Text File
|
1995-11-10
|
22KB
|
656 lines
{$D+} { MacsBug symbols on }
{$R-} { No range checking }
UNIT draw;
INTERFACE
USES quickdraw, toolUtils, scrap, standardFile,prlxdefinitions,
prlxLibraries;
PROCEDURE entrypoint(plist: prlxptr);
IMPLEMENTATION
CONST
openCommand = 1;
closeCommand = 2;
lineCommand = 3;
rectCommand = 4;
textCommand = 5;
penSizeCommand = 6;
penModeCommand = 7;
penPatCommand = 8;
foreColorCommand = 9;
backColorCommand = 10;
eraseCommand = 11;
ovalCommand = 12;
TYPE
(* rectPtr = ^rect; *)
pickKind = (pickLine, pickRect,pickOval, pickText, pickPenSize, pickPenMode,
pickPenPat, pickForeColor, pickBackColor);
pickHandle = ^pickPtr;
pickPtr = ^pickRec;
pickRec = RECORD
sized: boolean;
boundsRect: rect;
next: pickHandle;
CASE kind: pickKind OF
pickLine:
(lineStart, lineEnd: point);
pickRect,pickOval:
(r: rect);
pickText:
(s: stringHandle;
p: point);
pickPenSize:
(width, height: integer);
pickPenMode:
(m: integer);
pickPenPat:
(patternIndex: integer);
pickForeColor:
(colorIndex: integer);
pickBackColor:
(colorIndxex: integer);
END;
drawingRecord = RECORD
pen: penState;
foregroundColor, backgroundColor: longint;
END;
graphicWindowPtr = ^graphicWindowRec;
graphicWindowRec = RECORD
window: windowRecord;
occupied: boolean;
pick, lastPick: pickHandle;
picturePresent: boolean; {i.e. at least one visible
command}
boundsRect: rect;
defaultState, currentState: drawingRecord;
oldClip: rgnHandle;
END;
PROCEDURE main(plist: prlxptr);
FORWARD;
PROCEDURE entrypoint(plist: prlxptr);
BEGIN
main(plist);
END;
FUNCTION integerMin(a, b: longint): longint;
BEGIN
IF a > b THEN
integerMin := b
ELSE
integerMin := a;
END;
FUNCTION integerMax(a, b: longint): longint;
BEGIN
IF a < b THEN
integerMax := b
ELSE
integerMax := a;
END;
PROCEDURE getDrawingState(theWindow: graphicWindowPtr;
VAR state: drawingRecord);
BEGIN
WITH state DO
BEGIN
getPenState(pen);
foreGroundColor := windowPtr(theWindow)^.fgColor;
backGroundColor := windowPtr(theWindow)^.bkColor;
END;
END;
PROCEDURE setDrawingState(VAR state: drawingRecord);
BEGIN
WITH state DO
BEGIN
setPenState(pen);
foreColor(foreGroundColor);
backColor(backGroundColor);
END;
END;
FUNCTION qdColor(colorIndex: longint): longint;
BEGIN
CASE colorIndex OF
0: qdColor := blackColor;
1: qdColor := yellowColor;
2: qdColor := magentaColor;
3: qdColor := redColor;
4: qdColor := cyanColor;
5: qdColor := greenColor;
6: qdColor := blueColor;
7: qdColor := whiteColor;
END;
END;
FUNCTION drawHandler(theWindow: graphicWindowPtr;
parameter: longint;
message: integer): longint;
VAR
s: str255;
oldPort: grafPtr;
scrapPic: picHandle;
rptr: rectPtr;
theRect1,theRect2: rect;
ignoreBoolean: boolean;
ignoreLongint: longint;
PROCEDURE drawpick(theWindow: graphicWindowPtr);
VAR
myPick: pickHandle;
pat: pattern;
theRect: rect;
BEGIN
setDrawingState(theWindow^.defaultState);
getClip(theWindow^.oldClip);
theRect := windowPtr(theWindow)^.portRect;
theRect.bottom := theRect.bottom - 15;
theRect.right := theRect.right - 15;
clipRect(theRect);
myPick := theWindow^.pick;
WHILE myPick <> NIL DO
BEGIN
hlock(handle(myPick));
WITH myPick^^ DO
BEGIN
CASE kind OF
pickLine:
BEGIN
moveTo(lineStart.h, lineStart.v);
lineTo(lineEnd.h, lineEnd.v);
END;
pickRect: frameRect(r);
pickOval: frameOval(r);
pickText:
BEGIN
moveTo(p.h, p.v);
hLock(handle(s));
drawString(s^^);
hUnLock(handle(s));
END;
pickPenSize: penSize(width, height);
pickPenMode: penMode(m);
pickPenPat:
BEGIN
getIndPattern(pat, sysPatListID, patternIndex);
penPat(pat);
END;
pickForeColor: foreColor(qdColor(colorIndex));
pickBackColor: backColor(qdColor(colorIndex));
END;
hUnlock(handle(myPick));
myPick := myPick^^.next;
END;
END;
setClip(theWindow^.oldClip);
setDrawingState(theWindow^.defaultState);
END;
BEGIN
drawHandler := messageOK;
CASE message OF
eventActivate, eventResume:
BEGIN
getport(oldport);
setPort(windowPtr(theWindow));
drawGrowIcon(windowPtr(theWindow));
setport(oldPort);
END;
eventGetGrowLimit:
IF theWindow^.picturePresent THEN
BEGIN
rptr := rectPtr(parameter);
WITH rptr^ DO
BEGIN
topLeft := theWindow^.boundsRect.topLeft;
botRight := theWindow^.boundsRect.botRight;
bottom := bottom + 16;
right := right + 16;
END;
END;
eventSetWindowSize:
BEGIN
getport(oldport);
setPort(windowPtr(theWindow));
theRect1 := windowPtr(theWindow)^.portRect;
WITH theRect1 DO
BEGIN
bottom:=bottom-16;
right := right - 16;
END;
sizeWindow(windowPtr(theWindow), loword(parameter),
hiword(parameter), false);
theRect2 := windowPtr(theWindow)^.portRect;
invalRect(theRect2);
WITH theRect2 DO
BEGIN
bottom := bottom -16;
right := right -16;
END;
ignoreBoolean:=sectRect(theRect1, theRect2, theRect1);
validRect(theRect1);
setport(oldPort);
END;
eventUpdate:
BEGIN
getport(oldport);
setPort(windowPtr(theWindow));
beginUpdate(windowPtr(theWindow));
eraseRect(windowPtr(theWindow)^.portRect);
drawGrowIcon(windowPtr(theWindow));
drawPick(theWindow);
UpdtControl(windowPtr(theWindow), windowPeek(theWindow)^.updateRgn);
endUpdate(windowPtr(theWindow));
setport(oldPort);
END;
eventQuit: drawHandler := messageQuit;
eventMenuSelect:
BEGIN
getport(oldport);
setPort(windowPtr(theWindow));
IF (hiword(parameter) = editmenu) AND (loword(parameter) =
copyitem) THEN
BEGIN
IF theWindow^.picturePresent THEN
clipRect(theWindow^.boundsRect)
ELSE
clipRect(windowPtr(theWindow)^.portRect);
scrapPic := openPicture(windowPtr(theWindow)^.portRect);
drawPick(theWindow);
closePicture;
hlock(handle(scrapPic));
IF zeroScrap = noErr THEN
IF putScrap(getHandleSize(handle(scrapPic)), 'PICT',
handle(scrapPic)^) = noErr THEN
IF unloadScrap = noErr THEN drawHandler := messageOK;
hUnLock(handle(scrapPic));
END
ELSE IF (hiword(parameter) = editmenu) AND (loword(parameter) =
cutitem) THEN
BEGIN
IF theWindow^.picturePresent THEN
frameRect(theWindow^.boundsRect);
END
ELSE
drawHandler := messageNoReply;
setport(oldPort);
hiliteMenu(0);
END;
OTHERWISE drawHandler := messageNoReply;
END;
END;
PROCEDURE main;
VAR
s: str255;
i: integer;
l, m: longint;
newPick: pickHandle;
pat: pattern;
PROCEDURE draw;
VAR
theRect: rect;
theWindow: graphicWindowPtr;
result: longint;
p: procPtr;
st: str255;
u, x, y, z: longint;
oldPort: grafptr;
aControl: controlHandle;
myFontInfo: fontInfo;
PROCEDURE addPick(p: pickHandle;
theWindow: graphicWindowPtr);
VAR
q: pickHandle;
BEGIN
IF theWindow^.pick = NIL THEN
theWindow^.pick := p
ELSE
theWindow^.lastPick^^.next := p;
theWindow^.lastPick := p;
p^^.next := NIL;
IF theWindow^.picturePresent THEN
BEGIN
IF p^^.sized THEN
unionRect(theWindow^.boundsRect, p^^.boundsRect,
theWindow^.boundsRect);
END
ELSE
BEGIN
theWindow^.boundsRect := p^^.boundsRect;
theWindow^.picturePresent := p^^.sized;
END;
END;
BEGIN
plist^.determinate := true;
newPick := NIL;
getPort(oldPort);
theWindow := graphicWindowPtr(plist^.data[2]);
IF theWindow^.occupied THEN
BEGIN
setPort(windowPtr(theWindow));
setDrawingState(theWindow^.currentState);
getClip(theWindow^.oldClip);
theRect := windowPtr(theWindow)^.portRect;
theRect.bottom := theRect.bottom - 15;
theRect.right := theRect.right - 15;
clipRect(theRect);
END;
CASE value(1, plist) OF
openCommand:
IF NOT graphicWindowPtr(plist^.data[2])^.occupied THEN
BEGIN { new window }
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
u := value(subterm(3, 2, plist), plist);
z := value(subterm(4, 2, plist), plist);
st := text(2, plist);
setRect(theRect, y, x, z, u);
p := @drawHandler;
theWindow := graphicWindowPtr(newWindow(ptr(plist^.data[2]),
theRect, st, false,
documentProc,
pointer( - 1), false,
longint(p)));
setPort(windowPtr(theWindow));
graphicWindowPtr(theWindow)^.occupied := true;
graphicWindowPtr(theWindow)^.pick := NIL;
graphicWindowPtr(theWindow)^.picturePresent := false;
setRect(theRect, z - 16, x, z - 1, u - 16);
aControl := newControl(windowPtr(theWindow), theRect, '', true,
0, 0, 10, scrollBarProc, 0);
setRect(theRect, y, u - 16, z - 16, u);
aControl := newControl(windowPtr(theWindow), theRect, '', true,
0, 0, 10, scrollBarProc, 0);
getDrawingState(theWindow, theWindow^.defaultState);
theWindow^.oldClip := newRgn;
getClip(theWindow^.oldClip);
showWindow(windowPtr(theWindow));
END;
eraseCommand:
WITH theWindow^ DO
IF occupied THEN
BEGIN { only if occupied }
WHILE pick <> NIL DO
BEGIN
newPick := pick^^.next;
disposHandle(handle(pick));
pick := newPick;
END;
pick := NIL;
picturePresent := false;
setDrawingState(theWindow^.defaultState);
theRect := windowPtr(theWindow)^.portRect;
eraseRect(theRect);
invalRect(theRect);
END;
closeCommand:
WITH theWindow^ DO
IF occupied THEN
BEGIN { only if occupied }
WHILE pick <> NIL DO
BEGIN
newPick := pick^^.next;
disposHandle(handle(pick));
pick := newPick;
END;
occupied := false;
pick := NIL;
picturePresent := false;
disposeRgn(theWindow^.oldClip);
closeWindow(windowPtr(plist^.data[2]));
END;
lineCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
u := value(subterm(3, 2, plist), plist);
z := value(subterm(4, 2, plist), plist);
MoveTo(x, y);
Lineto(u, z);
WITH newPick^^ DO
BEGIN
sized := true;
boundsRect.top := integerMin(y, z);
boundsRect.left := integerMin(x, u);
boundsRect.bottom := integerMax(y,
z) + theWindow^.currentState.pen.pnSize.
v;
boundsRect.right := integerMax(x,
u) + theWindow^.currentState.pen.pnSize.h
;
kind := pickLine;
lineStart.h := x;
lineStart.v := y;
lineEnd.h := u;
lineEnd.v := z;
END;
addPick(newPick, theWindow);
END;
textCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
st := text(subterm(3, 2, plist), plist);
MoveTo(x, y);
DrawString(st);
getFontInfo(myFontInfo);
WITH newPick^^ DO
BEGIN
sized := true;
boundsRect.top := y - myFontINfo.ascent;
boundsRect.left := x;
boundsRect.bottom := y + myFontINfo.descent;
boundsRect.right := x + stringWidth(st);
kind := pickText;
p.h := x;
p.v := y;
s := newString(st);
END;
addPick(newPick, theWindow);
END;
ovalCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
u := value(subterm(3, 2, plist), plist);
z := value(subterm(4, 2, plist), plist);
setRect(theRect, x, y, u, z);
frameOval(theRect);
WITH newPick^^ DO
BEGIN
sized := true;
boundsRect := theRect;
kind := pickOval;
r := theRect;
END;
addPick(newPick, theWindow);
END;
rectCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
u := value(subterm(3, 2, plist), plist);
z := value(subterm(4, 2, plist), plist);
setRect(theRect, x, y, u, z);
frameRect(theRect);
WITH newPick^^ DO
BEGIN
sized := true;
boundsRect := theRect;
kind := pickRect;
r := theRect;
END;
addPick(newPick, theWindow);
END;
penSizeCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
y := value(subterm(2, 2, plist), plist);
penSize(x, y);
WITH newPick^^ DO
BEGIN
sized := false;
kind := pickPenSize;
width := x;
height := y;
END;
addPick(newPick, theWindow);
END;
penModeCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
penMode(x);
WITH newPick^^ DO
BEGIN
sized := false;
kind := pickPenMode;
m := x;
END;
addPick(newPick, theWindow);
END;
penPatCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
getIndPattern(pat, sysPatListID, x);
penPat(pat);
WITH newPick^^ DO
BEGIN
sized := false;
kind := pickPenPat;
patternIndex := x;
END;
addPick(newPick, theWindow);
END;
foreColorCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
foreColor(qdColor(x));
WITH newPick^^ DO
BEGIN
sized := false;
kind := pickForeColor;
colorIndex := x;
END;
addPick(newPick, theWindow);
END;
backColorCommand:
IF theWindow^.occupied THEN
BEGIN
newPick := pickHandle(newHandle(sizeOf(pickRec)));
x := value(subterm(1, 2, plist), plist);
backColor(qdColor(x));
WITH newPick^^ DO
BEGIN
sized := false;
kind := pickBackColor;
colorIndex := x;
END;
addPick(newPick, theWindow);
END;
END; { case }
IF theWindow^.occupied THEN
BEGIN
getDrawingState(theWindow, theWindow^.currentState);
setDrawingState(theWindow^.defaultState);
setClip(theWindow^.oldClip);
END;
IF oldPort <> grafPtr(theWindow) THEN setPort(oldPort);
END; { procedure }
BEGIN
WITH plist^ DO
BEGIN
CASE request OF
getPRLXInfo:
begin
data[1] := 1; {number of predicates defined}
data[2]:=eventsVersion;
end;
initialisepredicate:
CASE id OF
1: {draw/3}
BEGIN
s := 'draw'; {name}
data[1] := 3; {arity - command,argument,result}
data[2] := longint(newPtr(sizeOf(graphicWindowRec))); {permanent
data}
graphicWindowPtr(data[2])^.occupied := false;
END;
OTHERWISE
errorstr('predicate index out of range at initialise', plist);
END;
callpredicate:
BEGIN
successful := true;
CASE id OF
1: draw;
OTHERWISE
errorstr('predicate index out of range at call', plist);
END;
END;
closepredicate:
BEGIN
CASE id OF
1: {draw} ;
OTHERWISE
errorstr('predicate index out of range at close', plist);
END;
END;
OTHERWISE errorstr('unknown call to external procedures', plist);
END;
END;
END;
END.
